home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d3 / dbmail.arc / ML0440.PRG < prev    next >
Text File  |  1988-06-18  |  3KB  |  145 lines
  1. NOTE ML0440 - ADD AND REMOVE CODES FROM THE CODES FIELD FROM SELECTED RECORDS    9/23/84
  2. DO ML0442
  3. SELECT PRIMARY
  4. USE &FDEV
  5. STORE ',,'    TO VAR
  6. STORE 17    TO OFSET
  7. STORE LEN(CODES)    TO MAX
  8. STORE ','    TO DELIM
  9. @ 14,0 SAY '    NOTE: This routine does NOT check and may insert the duplicate of a code.'
  10. @ 15,0 SAY 'Enter Code Values to ADD to Codes Field of Selected Records.'
  11. DO ML0010
  12. STORE $(VAR,2, LEN(VAR)-1 )    TO AC
  13. STORE VAR#',,'    TO ADD
  14. STORE MAX-LEN(AC)    TO ACL
  15. @ 14,0
  16. @ 15,0 SAY 'Enter Code Values to DELETE from Codes Field of Selected Records.'
  17. STORE ',,'    TO VAR
  18. DO ML0010A
  19.  
  20. IF .NOT.ADD .AND. V=0
  21.     @ 15,0
  22.     @ 15,0 SAY 'NO Code Information Entered. Returning to Menu. Press any Key to Continue.'
  23.     WAIT
  24.     DO ML0441
  25.     RETURN
  26.     ENDIF
  27.  
  28. IF OPT=1
  29.     DO ML0201
  30.     ENDIF
  31. IF OPT=2
  32.     DO ML0202
  33.     ENDIF
  34. IF OPT=3
  35.     SAVE TO ML0440
  36.     RELEASE ALL
  37.     DO ML0203
  38.     RESTORE FROM ML0440
  39.     IF .NOT.FILE('MLSUB1.DBF')
  40.         DO ML0441
  41.         RETURN
  42.         ENDIF
  43.     ENDIF
  44.  
  45. SELECT PRIMARY
  46. USE MLSUB1
  47. GOTO BOTTOM
  48. ?
  49. ? #
  50. ?? ' RECORDS SELECTED.'
  51.  
  52. IF #=0
  53.     ?
  54.     ? 'NO Records Selected for Update. Press Any Key to Continue.'
  55.     DO ML0441
  56.     WAIT
  57.     RETURN
  58.     ENDIF
  59.  
  60. ?
  61. ACCEPT 'Do you wish to continue? (Y/N) ' TO RESP
  62. IF !(RESP)='N'
  63.     DO ML0441
  64.     RETURN
  65.     ENDIF
  66. SELECT SECONDARY
  67. USE &FDEV INDEX &FDEV
  68. SELECT PRIMARY
  69. GOTO TOP
  70. ERASE
  71. @ 10,10 SAY 'Update Mailing List File for ADD/DELETE Codes.'
  72. @ 14,10 SAY '   0 Selected Records Processed.'
  73. STORE 0    TO NOUP
  74.  
  75. DO WHILE .NOT.EOF
  76. STORE STR(RECID,4)    TO KEY
  77. SELECT SECONDARY
  78. FIND &KEY
  79. IF #>0
  80.     STORE TRIM(CODES)    TO VAR
  81.     STORE LEN(VAR)    TO L
  82.     STORE 0    TO N
  83.  
  84.     DO WHILE N<V .AND. VAR#',,'
  85.     STORE N+1    TO N
  86.     STORE STR(N,1+INT(N/10) )    TO VC
  87.     STORE @( CD&VC ,VAR)    TO P
  88.     STORE L&VC    TO R
  89.  
  90.     DO CASE
  91.     CASE P>1 .AND. R+P-1<L
  92.         STORE $(VAR,1,P)+$(VAR, P+R, L-R-P+1)    TO VAR
  93.     CASE P=1 .AND. R<L
  94.         STORE $(VAR,R,L-R+1)    TO VAR
  95.     CASE P>1 .AND. R+P-1=L
  96.         STORE $(VAR,1,P)    TO VAR
  97.     CASE P=1 .AND. R=L
  98.         STORE ',,'    TO VAR
  99.     ENDCASE
  100.     IF P>0
  101.         STORE L-R+1    TO L
  102.         ENDIF
  103.     ENDDO
  104.  
  105.     IF ADD.AND. L<ACL
  106.         IF VAR=',,'
  107.             REPLACE CODES WITH DELIM+AC
  108.         ELSE
  109.             REPLACE CODES WITH VAR+AC
  110.             ENDIF
  111.         STORE T    TO OK
  112.     ELSE
  113.         STORE .NOT.ADD    TO OK
  114.         IF .NOT.OK
  115.             STORE NOUP+1    TO NOUP
  116.             ENDIF
  117.         ENDIF
  118. ELSE
  119.     STORE F    TO OK
  120.     STORE NOUP+1    TO NOUP
  121.     ENDIF {#>0}
  122. SELECT PRIMARY
  123. REPLACE CP WITH OK
  124. @ 14,10 SAY # USING '9999'
  125. SKIP
  126. ENDDO
  127.  
  128. IF NOUP>0
  129.     ERASE
  130.     @ 10,10 SAY 'Unable to Update Mailing List Records with Code Data.'
  131.     @ 12,10 SAY 'Turn on Printer. Report to Follow. Press any Key when Printer Ready.'
  132.     WAIT
  133.     SET CONSOLE OFF
  134.     REPORT FORM ML0440 FOR .NOT.CP TO PRINT
  135.     SET CONSOLE ON
  136.     ENDIF
  137. DO ML0441
  138. RETURN
  139. NSOLE OFF
  140.     REPORT FORM ML0440 FOR .NOT.CP TO PRINT
  141.     SET CONSOLE ON
  142.     ENDIF
  143. DO ML0441
  144. RETURN
  145.